;;;-*- Mode:LISP; Package:LAMBDA; Base:10; Readtable:ZL -*-
; By Pace Willisson July 1988

(defun dump-conf (quad-slot)
  (let ((adr (- #x01000000 (* 256. 4))))
    (dotimes (i 256.)
      (let ((c (logand (%nubus-read quad-slot (+ adr (* i 4))) #xff)))
        (format t "~c" c)))))

(defun dump-remote-conf (remote-slot)
  (let* ((adr (- #x01000000 (* 256. 4)))
         (mapped-base (+ (mbc-map-slot remote-slot)
                         (if (bit-test 1 remote-slot)
                             1_24.
                           0))))
    (dotimes (i 256.)
      (let ((c (logand (nuread (+ mapped-base adr (* i 4))) #xff)))
        (format t "~c" c)))))

(defun print-mbc-map (&optional (read-func 'read-map))
  (dotimes (map-slot 128.)
    (let ((data (funcall read-func (* map-slot 4))))
      (cond ((and (not (zerop data))
                  (not (ldb-test (byte 1 0) data)))
             (format t "~&map[~3d.] is not valid, but is not 0" map-slot))
            ((ldb-test (byte 1 0) data)
             (format t "~&map[~3d.]: ~8x -> ~8x"
                     map-slot
                     (ash map-slot 25.)
                     (ash (dpb 0 (byte 1 0) data) 24.)))))))

(defun print-remote-mbc-map ()
  (print-mbc-map 'read-remote-map))

(defun alloc-mbc-slot ()
  (do ((map-slot 0 (+ map-slot 1))
       (last-map-slot (ash #xf0000000 -25.)))
      ((= map-slot last-map-slot)
       (ferror nil "couldn't find map slot"))
    (cond ((zerop (read-map (* map-slot 4)))
           (return map-slot)))))

(defun mbc-map-slot (remote-slot)
  (cond ((or (< remote-slot 0)
             (> remote-slot #xf))
         (ferror nil "remote slot must be between 0 and 15.")))
  (let ((map-slot (alloc-mbc-slot)))
    (write-map (* map-slot 4) (logior #xf1 remote-slot))
    (dpb (ldb (byte 1 0) remote-slot) (byte 1 24.) (ash map-slot 25.))))


(defun mbc-map-adr (remote-adr)
  (let ((map-slot (alloc-mbc-slot)))
    (write-map (* map-slot 4) (logior (ash (ldb (byte 7 25.) remote-adr) 1) 1))
    (dpb map-slot (byte 7 25.) (logand remote-adr #x01ffffff))))

(defun nuread (adr)
  (%nubus-read (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr)))

(defun nuwrite (adr data)
  (%nubus-write (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr) data))

(defun swap32 (x)
  (logior (ash (ldb (byte 8 0) x) 24.)
          (ash (ldb (byte 8 8) x) 16.)
          (ash (ldb (byte 8 16.) x) 8)
          (ldb (byte 8 24.) x)))

(defun getbuf ()
  (let ((buf (make-array 1024.)))
    (dotimes (i 1024)
      (aset (swap32 (%nubus-read #xfb (* i 4))) buf i))
    buf))

(defun pa (a)
  (dotimes (i (array-length a))
    (format t "(~d ~d) " i (aref a i))))


(defun check-a (a)
  (let ((start (aref a 0)))
    (dotimes (i (array-length a))
      (cond ((not (= (aref a i) (+ i start)))
             (format t "~&error ~d expected #x~x got #x~x" i (+ i start) (aref a i)))))))

(defun macread32 (adr)
  (swap32 (%nubus-read (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr))))

(defun nuread32 (adr)
  (%nubus-read (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr)))

(defun nuwrite32 (adr val)
  (%nubus-write (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr) val))

(defvar *mac-conf-stop-loc*)
(defvar *mac-conf-blk*)
(defvar *mac-conf-blk-size*)

(defun read-mac-conf (&optional (and-print t))
  (let ((adr #xfb000000))
    (if (not (= (macread32 adr) #x12345678))
        (ferror nil "not mac conf"))
    (if (not (= (macread32 (+ adr 4)) 5))
        (ferror nil "bad mac conf version"))
    (setq *mac-conf-stop-loc* (+ adr 8))
    (setq *mac-conf-blk* (macread32 (+ adr 12.)))
    (setq *mac-conf-blk-size* (macread32 (+ adr 16.))))
  (if and-print
      (format t "~&stop loc ~x; blk ~x; blk size ~d" *mac-conf-stop-loc* *mac-conf-blk* *mac-conf-blk-size*)))

(defun stop-mac ()
  (read-mac-conf)
  (%nubus-write (ldb (byte 8 24.) *mac-conf-stop-loc*) (ldb (byte 24. 0) *mac-conf-stop-loc*) 1))

(defun beg-of-line ()
  (send *terminal-io*
        :set-cursorpos
        0
        (nth-value 1 (send *terminal-io* :read-cursorpos :character))
        :character)
  (send *terminal-io* :clear-eol))

(defun twoway ()
  (clear-map)
  (read-mac-conf)
  (format t "~&write and read a test pattern in remote memory")
  (format t "~&Using remote address #x~x" *mac-conf-blk*)
  (format t "~&Each pass writes and reads ~d. bytes" *mac-conf-blk-size*)
  (format t "~2%")
  (let ((pass 0)
        (error-count 0)
        (local-adr (mbc-map-adr *mac-conf-blk*)))
    (do-forever
      (cond (t (zerop (mod pass 10.))
             (send *terminal-io*
                   :set-cursorpos
                   0
                   (nth-value 1 (send *terminal-io* :read-cursorpos :character))
                   :character)
             (send *terminal-io* :clear-eol)
             (format t "pass ~d error-count ~d" pass error-count)))
      (cond ((not (zerop pass))
             (do ((i 0 (+ i 4))
                  (pat (- pass 1) (logand #xffffffff (+ pat 1))))
                 ((= i *mac-conf-blk-size*))
               (let ((val (nuread32 (+ local-adr i))))
                 (cond ((not (= val pat))
                        (write-config-reg 6)
                        (write-config-reg 2)
                        (incf error-count)
                        (format t "~&error ~d: pass ~d offset ~d expected #x~x got #x~x, then got #x~x~&"
                                error-count pass i pat val (nuread32 (+ local-adr i)))))))))
      (do ((i 0 (+ i 4))
           (pat pass (logand #xffffffff (+ pat 1))))
          ((= i *mac-conf-blk-size*))
        (nuwrite32 (+ local-adr i) pat))
      (incf pass))))

(defun twoway-lmap ()
  (clear-map)
  (read-mac-conf)
  (format t "~&write and read a test pattern in remote memory, and read and write to local map")
  (format t "~&Using remote address #x~x" *mac-conf-blk*)
  (format t "~&Each pass writes and reads ~d. bytes" *mac-conf-blk-size*)
  (format t "~2%")
  (let ((pass 0)
        (error-count 0)
        (local-adr (mbc-map-adr *mac-conf-blk*))
        (testslot (* 4 (alloc-mbc-slot))))
    (format t "~&map testslot = ~x~%" testslot)
    (do-forever
      (cond (t (zerop (mod pass 10.))
             (send *terminal-io*
                   :set-cursorpos
                   0
                   (nth-value 1 (send *terminal-io* :read-cursorpos :character))
                   :character)
             (send *terminal-io* :clear-eol)
             (format t "pass ~d error-count ~d" pass error-count)))
      (cond ((not (zerop pass))
             (do ((i 0 (+ i 4))
                  (pat (- pass 1) (logand #xffffffff (+ pat 1))))
                 ((= i *mac-conf-blk-size*))
               (let ((val (nuread32 (+ local-adr i))))
                 (cond ((not (= val pat))
                        (incf error-count)
                        (format t "~&error ~d: pass ~d offset ~d expected #x~x got #x~x~&"
                                error-count pass i pat val)))))
             (do ((i 1 (+ i 1))
                  (pat (logand (- pass 1) #xfe) (+ pat 2)))
                 ((= i 128))
               (let ((val (read-map (* i 4))))
                 (cond ((not (= val (logand pat #xfe)))
                        (format t "~&error ~d: local map #x~x expected #x~x got #x~x~&"
                                error-count i (logand pat #xfe) val)))))))
      (do ((i 0 (+ i 4))
           (pat pass (logand #xffffffff (+ pat 1))))
          ((= i *mac-conf-blk-size*))
        (nuwrite32 (+ local-adr i) pat))
      (do ((i 1 (+ i 1))
           (pat (logand pass #xfe) (+ pat 2)))
          ((= i 128))
        (write-map (* i 4) pat))
      (incf pass))))

(defun twoway-rmap ()
  (clear-map)
  (read-mac-conf)
  (format t "~&write and read a test pattern in remote memory, and read and write to local map")
  (format t "~&Using remote address #x~x" *mac-conf-blk*)
  (format t "~&Each pass writes and reads ~d. bytes" *mac-conf-blk-size*)
  (format t "~2%")
  (let ((pass 0)
        (error-count 0)
        (local-adr (mbc-map-adr *mac-conf-blk*))
        (testslot (* 4 (alloc-mbc-slot))))
    (format t "~&map testslot = ~x~%" testslot)
    (do-forever
      (cond (t (zerop (mod pass 10.))
             (send *terminal-io*
                   :set-cursorpos
                   0
                   (nth-value 1 (send *terminal-io* :read-cursorpos :character))
                   :character)
             (send *terminal-io* :clear-eol)
             (format t "pass ~d error-count ~d" pass error-count)))
      (cond ((not (zerop pass))
             (do ((i 0 (+ i 4))
                  (pat (- pass 1) (logand #xffffffff (+ pat 1))))
                 ((= i *mac-conf-blk-size*))
               (let ((val (nuread32 (+ local-adr i))))
                 (cond ((not (= val pat))
                        (incf error-count)
                        (format t "~&error ~d: pass ~d offset ~d expected #x~x got #x~x~&"
                                error-count pass i pat val)))))
             (do ((i 1 (+ i 1))
                  (pat (logand (- pass 1) #xfe) (+ pat 2)))
                 ((= i 128))
               (let ((val (read-remote-map (* i 4))))
                 (cond ((and (zerop (logand val 1))
                             (not (= val (logand pat #xfe))))
                        (format t "~&error ~d: local map #x~x expected #x~x got #x~x then got #x~x~&"
                                error-count i (logand pat #xfe) val (read-remote-map (* i 4)))))))))
      (do ((i 0 (+ i 4))
           (pat pass (logand #xffffffff (+ pat 1))))
          ((= i *mac-conf-blk-size*))
        (nuwrite32 (+ local-adr i) pat))
      (do ((i 1 (+ i 1))
           (pat (logand pass #xfe) (+ pat 2)))
          ((= i 128))
        (let ((old (read-remote-map (* i 4))))
          (cond ((zerop (logand old 1))
                 (write-remote-map (* i 4) pat)))))
      (incf pass))))


(defun mac-inc ()
  (init-bc-tal)
  (clear-map)
  (read-mac-conf)
  (let ((ladr (mbc-map-adr *mac-conf-blk*)))
    (print-mbc-map)
    (format t "~&ladr = #x~x" ladr)
    (cond ((y-or-n-p "Continue? ")
           (do ((i 0 (+ i 1)))
               (())
             (nuwrite32 ladr i)
             (let ((val (nuread32 ladr)))
               (if (not (= val i))
                   (format t "~&error: expected #x~x got #x~x" i val))))))))

(defun mac-inc0 ()
  (do ((i 0 (+ i 1)))
      (())
    (%nubus-write 0 0 i)
    (let ((val (%nubus-read 0 0)))
      (if (not (= val i))
          (format t "~&error: expected #x~x got #x~x" i val)))))

(defun mac-read0 ()
  (init-bc-tal)
  (let ((ladr (mbc-map-adr 0)))
    (if (not (zerop ladr))
        (ferror nil "bad adr"))
    (format t "~&*0 = ~x" (%nubus-read 0 0))))

(defun mac-read ()
  (init-bc-tal)
  (clear-map)
  (let* ((radr 0)
         (ladr (mbc-map-adr radr))
         orig)
    (format t "~%looping reading address #x~x in mac~%" radr)
    (setq orig (nuread32 ladr))
    (do-forever (nuread32 ladr))))

(defun mac-read1 ()
  (init-bc-tal)
  (read-mac-conf)
  (let ((ladr (mbc-map-adr *mac-conf-blk*)))
    (print-mbc-map)
    (format t "~&going to loop reading mac adr #x~x (local #x~x)~&" *mac-conf-blk* ladr)
    (cond ((y-or-n-p "Continue? ")
           (do-forever (nuread32 ladr))))))

(defun mbc-init ()
  (init-bc-tal)
  (write-config-reg 2)
  (mbc-map-adr 0))

(defvar rqb1 nil)
(defvar rqb2 nil)

(defun disk-test ()
  (let ((error-count 0) (pass 0))
    (if (null rqb1) (setq rqb1 (si:get-disk-rqb 20.)))
    (if (null rqb2) (setq rqb2 (si:get-disk-rqb 20.)))
    (si:disk-read rqb1 0 0)
    (format t "~&")
    (do-forever
      (dotimes (x 4)
        (si:disk-read rqb2 0 0)
        (cond ((not (string-equal (array-leader rqb1 3) (array-leader rqb2 3)))
                (incf error-count))))
      (incf pass)
      (beg-of-line)
      (format t "pass ~d error count ~d" pass error-count))))

(defun pmap ()
  (dotimes (i 128.)
    (format t "~x " (read-map (* i 4)))))

(defsubst flash-led ()
  (write-config-reg 6)
  (write-config-reg 2))

(defun wones (&aux (win 0))
  (do-forever
    (%nubus-write 0 0 -1)
    (let ((x (%nubus-read 0 0)))
      (cond ((not (= x #xffffffff))
             (flash-led)
             (format t "~&win ~d " win)
             (setq win 0)
;            (y-or-n-p "~x continue? " x)
             )
            (t
             (incf win))))))

(defun rones ()
  (do-forever
    (if (not (= (%nubus-read 0 0) #xffffffff)) (return))))
